home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 …SCII & the Runetime Code / ADC Developer CD (1992-07) (''Butch ASCII And The Runtime Code'')_iso / Dev.CD 199207.iso / Development Platforms / HyperCard Related / XCMDs & XFCNs / Logic Manager / Tools / LMforeigns.p < prev   
Encoding:
Text File  |  1991-03-13  |  19.5 KB  |  964 lines  |  [TEXT/MPS ]
  1. %
  2. %    LMforeigns.p:        Foreign and Builtin routines for the Logic Manager
  3. %
  4. %      Copyright (c) 1988, 1989, 1990 by Apple Computer, Inc.
  5. %      Logic Manager 1.0d2
  6. %      Ruben Kleiman (Apple Computer, Inc; Advanced Technology Group)
  7. %      Thanks to Michael Poe, Steve Weyer, Larry Tesler, not least
  8. %      to Andy Turk and unsung others.
  9.  
  10. %      This code is the property of Apple Computer, Inc. and is considered
  11. %      company confidential.  Use of it is at the user's own risk.  Apple
  12. %      Computer, Inc. shall not be liable for any direct or indirect
  13. %      physical or emotional harm or loses resulting from the use of
  14. %      the Logic Manager.
  15. %
  16.  
  17.  
  18. %
  19. %    +Arg         is an input argument
  20. %    -Arg        is an output argument
  21. %    ?Arg        is not necessarily input or output, usage varies
  22. %
  23.  
  24. %
  25. %%    cut
  26. %
  27. %    Removes any choicepoints created since the parent procedure call.
  28. %
  29.  
  30. rule( cut, cut ).
  31.  
  32. %
  33. %%    abolish( +Name, +Arity )
  34. %
  35. %    Removes all clauses for the procedure Name/Arity from the database.
  36. %
  37.  
  38. %
  39. %%    write( +Term )
  40. %
  41. %    Writes a printed representation of Term to the standard output.
  42. %
  43.  
  44. %
  45. %%    nl
  46. %
  47. %    Prints a new-line character to standard output.
  48. %
  49.  
  50. %
  51. %%    call( +Goal )
  52. %
  53. %    Succeeds when Goal is provable.
  54. %
  55.  
  56. %
  57. %%    asserta( +Clause )
  58. %
  59. %    Adds the Clause to the beginning of the specified procedure
  60. %    in the database.
  61. %
  62.  
  63. %
  64. %%    assertz( +Clause )
  65. %
  66. %    Adds the Clause to the end of the specified procedure
  67. %    in the database.
  68. %
  69.  
  70. %
  71. %%    mangle( +ArgN, +Structure, +Argument )
  72. %
  73. %    The ArgNth argument of the compound term, Structure, is destructively
  74. %    modified to be Argument.  This modification SURVIVES failure.
  75. %
  76.  
  77. %
  78. %%     =( ?X, ?Y )
  79. %
  80. %    Unifies X and Y.
  81. %
  82.  
  83. =(X,X).
  84.  
  85. %
  86. %%    read( ?Term )
  87. %
  88. %    Pauses to allow the user to type in a term to standard input.  This
  89. %    term is then unified with Term.
  90. %
  91.  
  92. %
  93. %%    lockedproc( +Name, +Arity )
  94. %
  95. %    Succeeds when the procedure, Name/Arity, has been locked.
  96. %
  97.  
  98. %
  99. %%    lockproc( +Name, +Arity )
  100. %
  101. %    Locks the procedure, Name/Arity.  This means that abolish/2,
  102. %    clause/2, retract/1, asserta/1, and assertz/2 will never modify
  103. %    or examine Name/Arity.
  104. %
  105.  
  106. %
  107. %%    compare( -Relation, +LeftArg, +RightArg )
  108. %
  109. %    Relation will be bound to '>', '<' or '=' depending on whether:
  110. %
  111. %        LeftArg < RightArg        or
  112. %        LeftArg = RightArg        or
  113. %        LeftArg > RightArg
  114. %
  115. %
  116. %        variables < numbers < atoms < structured terms < buffers
  117. %
  118. %    compare/3 defines the standard order.
  119. %
  120.  
  121. rule( compare( Relation, Left, Right ),
  122.     and( $compare( Left, Right ),
  123.          getterm( Relation )
  124. )).
  125.  
  126. %
  127. %%    @<( +Left, +Right )
  128. %%    @=<( +Left, +Right )
  129. %%    @>=( +Left, +Right )
  130. %%    @>( +Left, +Right )
  131. %%    ==( +Left, +Right )
  132. %
  133. %    These predicates use compare/3 to compare their arguments according
  134. %    to the standard order.
  135. %
  136.  
  137. rule( @<( Left, Right ),
  138.     compare( <, Left, Right )).
  139.  
  140. rule( @=<( Left, Right ),
  141.     and( compare( <, Left, Right ),
  142.          cut
  143. )).
  144. rule( @=<( Left, Right ),
  145.     compare( =, Left, Right )).
  146.  
  147. rule( @>( Left, Right ),
  148.     compare( >, Left, Right )).
  149.  
  150. rule( @>=( Left, Right ),
  151.     and( compare( >, Left, Right ),
  152.     cut
  153. )).
  154. rule( @>=( Left, Right ),
  155.     compare( =, Left, Right )).
  156.  
  157. rule(==( Left, Right ),
  158.     compare( =, Left, Right )).
  159.  
  160. %
  161. %%    different( +X, +Y )
  162. %
  163. %    Succeeds when X and Y are not ==/2.
  164. %
  165.  
  166. rule(different(X,X), 
  167.         and(cut, fail) ).
  168. different(_,_).
  169.  
  170. %
  171. %%    typeof( Term, Type )
  172. %
  173. %    Type is unified with an atom representing the type of Term
  174. %
  175. %        variable
  176. %        integer
  177. %        integer32
  178. %        atom
  179. %        compound
  180. %        float
  181. %        string
  182. %        buffer
  183. %
  184.  
  185. rule( typeof( Term, Type ),
  186.     and( $typeof( Term ),
  187.          getterm( Type )
  188. )).
  189.  
  190. %
  191. %%    number( +Arg )
  192. %
  193. %    Succeed when Arg is bound to an integer or a floating point.
  194. %
  195.  
  196. rule( number( N ),
  197.     and( typeof( N, Type ),
  198.     and( numberType( Type ),
  199.          cut
  200. ))).
  201.  
  202. numberType( integer ).
  203. numberType( integer32 ).
  204. numberType( float ).
  205.  
  206. %
  207. %%    arg( +ArgN, +Structure, -Argument )
  208. %
  209. %    Structure must be bound to a compound term.  The Nth argument of this
  210. %    term will be unified with Argument.
  211. %
  212.  
  213. rule( arg( Item, Structure, Argument ),
  214.     and( $arg( Item, Structure ),
  215.          getterm( Argument )
  216. )).
  217.  
  218. %
  219. %    functor( -Structure, +Name, +Arity )  also  functor( +Structure, -Name, -Arity )
  220. %
  221. %    When Structure is an unbound variable, a new compound term with
  222. %    a principal functor of Name/Arity will be unified with Structure.  All
  223. %    the arguments of the structure are fresh unbound variables.
  224. %
  225. %    In the other mode, the second and third arguments will be unified with
  226. %    the name and arity of the principal functor of Structure.
  227. %
  228.  
  229. rule(functor(Structure,Functor,Arity),
  230.         and(var(Structure),
  231.         and(cut,
  232.         and($build(Functor,Arity),getterm(Structure))))).
  233.  
  234.  
  235. rule(functor(Structure,Functor,Arity),
  236.         and($name(Structure),
  237.         and(getterm(Functor),
  238.         and($arity(Structure),getterm(Arity) )))).
  239.         
  240.  
  241. rule(name(Structure,Name),
  242.         and($name(Structure), getterm(Name) )).
  243. rule(arity(Structure,Arity),
  244.         and($arity(Structure), getterm(Arity) )).
  245.  
  246. %
  247. %%    nonvar( +Term )
  248. %%    var( +Term )
  249. %%    atom( +Term )
  250. %%    atomic( +Term )
  251. %%    integer( +Term )
  252. %
  253. %    These are used to identify the type of term passed.
  254. %    
  255.  
  256. rule( nonvar( Term ),
  257.     and( typeof( Term, variable ),
  258.     and( cut,
  259.          fail
  260. ))).
  261. nonvar( Term ).
  262.  
  263. rule( var( Term ),
  264.     typeof( Term, variable )
  265. ).
  266. rule( atom( Term ),
  267.     typeof( Term, atom )
  268. ).
  269.  
  270. rule( buffer( Term ),
  271.     typeof( Term, buffer )
  272. ).
  273.  
  274. rule( float( Term ),
  275.     typeof( Term, float )
  276. ).
  277.  
  278. atomicType( integer ).
  279. atomicType( integer32 ).
  280. atomicType( atom ).
  281.  
  282. rule( atomic( Term ),
  283.     and( typeof( Term, Type ),
  284.     and( atomicType( Type ),
  285.          cut
  286. ))).
  287.  
  288. integerType( integer ).
  289. integerType( integer32 ).
  290.  
  291. rule( integer( Term ),
  292.     and( typeof( Term, Type ),
  293.     and( integerType( Type ),
  294.          cut
  295. ))).
  296.  
  297. rule( nonvar( Term ),
  298.     and( var( Term ),
  299.     and( cut,
  300.          fail
  301. ))).
  302. nonvar( Term ).
  303.  
  304.  
  305. %
  306. %%    is(-Result,+Expression)
  307. %
  308. %    The result of the arithmetic evaluation of Expression is unified
  309. %    with Result.
  310. %
  311.  
  312. rule( is( Result, Expression ),
  313. %    and( writel( Expression ),
  314.     and( eval( Expression ),
  315.          getterm( Result )
  316. )).
  317.  
  318. %
  319. %%    atomchars( +Atom, -Chars )   also   atomchars( -Atom, +Chars )
  320. %
  321. %    Translates an atom into a list of its ASCII characters and
  322. %    vice versa.
  323. %
  324.  
  325. rule(atomchars(Atom,ExplodedAtom),
  326.         and(atomic(Atom),
  327.         and(cut,
  328.         and($atomchars(Atom),getterm(ExplodedAtom) )))).
  329.         
  330.         
  331. rule(atomchars(ImplodedAtom,Atom),
  332.         and(var(ImplodedAtom),
  333.         and($implode(Atom),getterm(ImplodedAtom) ))).
  334.         
  335. %
  336. %%    true
  337. %
  338. %    Always succeeds.
  339. %
  340.  
  341. true.
  342.  
  343.  
  344. %    
  345. %%    not( +Goal )
  346. %
  347. %    Succeeds when Goal is not provable.
  348. %
  349.  
  350.  
  351. rule(not(Goal),
  352.         and(call(Goal),
  353.         and(cut,fail))).
  354.         
  355. rule(not(Goal),true).
  356.  
  357. %
  358. %%    or( +Goal1, +Goal2 )
  359. %
  360. %    Succeeds when either Goal1 or Goal2 is provable.
  361. %
  362.  
  363. rule(or(Goal1,Goal2), call(Goal1)).
  364. rule(or(Goal1,Goal2), call(Goal2)).
  365.  
  366. %
  367. %%    and( +Goal, +Goal )
  368. %
  369. %    Succeeds when both Goal1 and Goal2 are both provable (in order).
  370. %
  371.  
  372. rule( and( Goal1, Goal2 ),
  373. %    and( writel( and1( Goal1 )),
  374.     and( call( Goal1 ),
  375. %    and( writel( and2( Goal2 )),
  376.          call( Goal2 )
  377. )).
  378.  
  379. %    
  380. %%    length( +List, -Length )
  381. %
  382. %    Length is unified with the length List.
  383. %
  384.  
  385. rule( length( List, Len ),
  386.     length2( List, 0, Len )).
  387.  
  388. length2( nil, Len, Len ).
  389. rule( length2( cons( _, Tail ), SoFar, Total ),
  390.     and( is( OneMore, add( SoFar, 1 )),
  391.          length2( Tail, OneMore, Total )
  392. )).
  393.  
  394. %
  395. %%    sort( +List, -SortedList )
  396. %
  397. %    List is sorted according to the standard order defined by compare/3.
  398. %    Duplicate elements (==/2) of List are removed.
  399. %
  400.  
  401.  
  402. rule(sort(List,SortedList),
  403.         and(length(List,Length),
  404.             sort(Length,List,_,SortedList) )).
  405.         
  406. rule(sort(2,cons(X1,L1),L,R),
  407.         and(cut,
  408.         and(comprises(L1,X2,L),
  409.         and(compare(Delta,X1,X2),
  410.             sort2(Delta,X1,X2,R) )))).
  411.         
  412. sort2(<,X1,X2,cons(X1,cons(X2,nil))).
  413. sort2(>,X1,X2,cons(X2,cons(X1,nil))).
  414. sort2(=,X1,X2,cons(X2,nil)).
  415.  
  416. rule(sort(1,cons(X,L),L,cons(X,nil)),
  417.         cut).
  418.         
  419. rule(sort(0,L,L,nil),cut).
  420. rule(sort(N,L1,L3,R),
  421.         and(is(N1,idiv(N,2)),
  422.         and(is(N2,sub(N,N1)),
  423.         and(sort(N1,L1,L2,R1),
  424.         and(sort(N2,L2,L3,R2),merge(R1,R2,R) ))))).
  425.         
  426. rule(merge(nil,R,R),cut).
  427. rule(merge(R,nil,R),cut).
  428.         
  429. rule(merge(R1,R2,cons(X,R)),
  430.         and( comprises(R1,X1,R1a),
  431.         and( comprises(R2,X2,R2a),
  432.         and( compare(Delta,X1,X2),merge2(Delta,X,X1,X2,R1,R2,R1a,R2a,R) )))).
  433.         
  434. rule(merge2(<,X,X,_,_,R2,R1a,_,R),
  435.         and(cut, 
  436.         merge(R1a,R2,R))).
  437.         
  438. rule(merge2(>,X,_,X,R1,_,_,R2a,R),
  439.     and(cut, 
  440.     merge(R1,R2a,R) )).
  441.         
  442. rule(merge2(=,X,X,_,_,_,R1a,R2a,R),
  443.     merge(R1a,R2a,R) ).
  444.  
  445.  
  446. comprises(cons(X,L),X,L).
  447.  
  448.  
  449. %    copy/2
  450. %
  451. %    Duplicates a term on the heap.
  452. %
  453. %    copy(+Original,-Duplicate)
  454.  
  455. rule(copy(Original,Duplicate),
  456.         and($copy(Original),getterm(Duplicate) )).
  457.         
  458.  
  459. %
  460. %%    findall( +Template, +Goal, -Solutions )
  461. %
  462. %    All the instances of Template when Goal is provable are
  463. %    collected into the list Solutions.  There is no quantification
  464. %    and Solutions may contain duplicates.
  465. %
  466.  
  467. rule(findall(Template,Call,Bag),
  468.         and(=(WorkingBag,cons(nil,nil)),
  469.         and(collect(Template,Call,WorkingBag), arg(1,WorkingBag,Bag) ))).
  470.         
  471. rule(collect(Template,Call,Bag),
  472.         and(call(Call),
  473.         and(copy(Template,CopiedTemplate),
  474.         and(addSolution(CopiedTemplate,Bag),fail )))).
  475.  
  476. collect(_,_,_).
  477.  
  478. rule(addSolution(Solution,Bag),
  479.         and(=(Bag,cons(nil,nil)),
  480.         and(cut,
  481.         and(=(SingleSolution,cons(Solution,nil)),
  482.         and(mangle(1,Bag,SingleSolution), mangle(2,Bag,SingleSolution) ))))).
  483.         
  484. rule(addSolution(Solution,Bag),
  485.         and(=(Bag,cons(_,BagEnd)),
  486.         and(=(NewEnd,cons(Solution,nil)),
  487.         and(mangle(2,Bag,NewEnd), mangle(2,BagEnd,NewEnd) )))).
  488.         
  489.                 
  490. %
  491. %    append( ?List1, ?List2, ?NewList )
  492. %
  493. %    NewList is the result of appending List1 before List2.
  494. %
  495.  
  496. append(nil,List2,List2).
  497. rule(append(cons(H,T),L,cons(H,R)), append(T,L,R) ).
  498.  
  499.  
  500. %
  501. %    univ( +Term, -List )  also  univ( -Term, +List )
  502. %
  503. %    Term is a compound term, and List is a list whose
  504. %    first element is the principal functor of Term, and whose other
  505. %    elements are the arguments of Term in order.
  506. %
  507.  
  508. rule( univ( Structure, cons( Functor, Args )),
  509.     and( functor( Structure, Functor, Arity ),
  510.     and( cut,
  511.          univInstall( Structure, 1, Arity, Args )
  512. ))).
  513.  
  514. rule( univ( Structure, cons( Functor, Args )),
  515.     and( atom( Functor ),
  516.     and( length( Args, Arity ),
  517.     and( cut,
  518.     and( functor( Structure, Functor, Arity ),
  519.          univInstall( Structure, 1, Arity, Args )
  520. )))))).
  521.  
  522. rule( univInstall( Struct, N, Arity, nil ),
  523.     and( @>( N, Arity ),
  524.          cut
  525. )).
  526. rule( univInstall( Struct, N, Arity, cons( Arg, Args )),
  527.     and( arg( N, Struct, Arg ),
  528.     and( is( N1, add( N, 1 )),
  529.          univInstall( Struct, N1, Arity, Args )
  530. ))).
  531.  
  532. %
  533. %%    writel( +Term )
  534. %
  535. %    writes Term to standard out followed by a new-line
  536. %
  537.  
  538. rule( writel( Term ),
  539.     and( write( Term ),
  540.          nl
  541. )).
  542.  
  543. rule( notlocked( Head ),
  544.     and( functor( Head, Name, Arity ),
  545.     and( lockedproc( Name, Arity ),
  546.     and( cut,
  547.          fail
  548. )))).
  549. notlocked( Head ).
  550.  
  551. %
  552. %%    getcount( ?Count )
  553. %
  554. %    Unifies Count with the inference countdown value.
  555. %
  556.  
  557. rule( getcount( X ),
  558.     and( getcount,
  559.          getterm( X )
  560. )).
  561.  
  562. %
  563. %%    clause( +Head, ?Body )
  564. %
  565. %    Succeeds when there is a clause in the database whose head is
  566. %    unifiable with Head and whose body is unifiable with Body.
  567. %
  568.  
  569. rule( clause( Head, Body ),
  570.     and( notlocked( Head ),
  571.     and( =( DecompState, rule( Head, nil )),
  572.     and( =( NormalState, nstate( Count, IState )),
  573.     and( getcount( Count ),
  574.     and( getistate( IState ),
  575.     and( decompilationOn( DecompState, NormalState ),
  576.     and( call( Head ),
  577.     and( decompilationOff( DecompState, NormalState ),
  578.     and( fixClause( DecompState ),
  579.          arg( 2, DecompState, Body )
  580. )))))))))).
  581.  
  582. rule( decompilationOn( DecompState, NormalState ),
  583.     changeState( 2, DecompState )
  584. ).
  585. rule( decompilationOn( DecompState, NormalState ),
  586.     turnOffDecompiler( NormalState )
  587. ).
  588.  
  589. rule( decompilationOff( DecompState, nstate( Count, IState )),
  590.     changeState( Count, IState )
  591. ).
  592. rule( decompilationOff( DecompState, NormalState ),
  593.     and( mangle( 2, DecompState, nil ),
  594.     and( changeState( 2, DecompState ),
  595.          fail
  596. ))).
  597.  
  598. rule( interrupt( decompilationOff( DState, NState )),
  599.     and( nonvar( DState ),
  600.     and( cut,
  601.          decompilationOff( DState, NState )
  602. ))).
  603.  
  604. rule( interrupt( turnOffDecompiler( nstate( Count, IState ))),
  605.     and( cut,
  606.     and( changeState( Count, IState ),
  607.          fail
  608. ))).
  609.  
  610. rule( interrupt( Goal ),
  611.     and( getistate( depthLimit ),
  612.     and( write( 'depth limit exceeded with ' ),
  613.     and( writel( Goal ),
  614.          halt
  615. )))).
  616.  
  617. rule( interrupt( Goal ),
  618.     and( getistate( DState ),
  619.     and( =( New, and( Goal, nil )),
  620.     and( mangle( 2, DState, New ),
  621.          changeState( 1, New )
  622. )))).
  623.  
  624. rule( getistate( X ),
  625.     and( getistate,
  626.          getterm( X ))).
  627.  
  628. rule( changeState( Count, InterruptField ),
  629.     and( setistate( InterruptField ),
  630.          setcount( Count )
  631. )).
  632. rule( fixClause( Clause ),
  633.     and( =( Clause, rule( _, nil )),
  634.     and( cut,
  635.          mangle( 2, Clause, true )
  636. ))).
  637. rule( fixClause( Body ),
  638.     and( arg( 2, Body, and( G, nil )),
  639.     and( cut,
  640.          mangle( 2, Body, G )
  641. ))).
  642. rule( fixClause( Body ),
  643.     and( arg( 2, Body, Tail ),
  644.          fixClause( Tail )
  645. )).
  646.  
  647. %
  648. %%    retract( +Clause )
  649. %
  650. %    Succeeds when Clause is a clause in the database.  After retract/1 succeeds,
  651. %    the clause is removed from the database.
  652. %
  653.  
  654. rule( retract( rule( Head, Body )),
  655.     and( cut,
  656.          retract2( Head, Body )
  657. )).
  658. rule( retract( Head ),
  659.     retract2( Head, true )
  660. ).
  661.  
  662. rule( retract2( Head, Body ),
  663.     and( notlocked( Head ),
  664.     and( functor( Head, Name, Arity ),
  665.     and( functor( Head2, Name, Arity ),
  666.     and( =( ProcState, clause( 0 )),
  667.     and( =( DState, rule( Head, nil )),
  668.     and( =( NState, nstate( Count, IState )),
  669.     and( getistate( IState ),
  670.     and( getcount( Count ),
  671.     and( decompilationOn( DState, NState ),
  672.     and( call( Head2 ),
  673.     and( decompilationOff( DState, NState ),
  674.     and( nextClause( ProcState ),
  675.     and( =( Head, Head2 ),
  676.     and( fixClause( DState ),
  677.     and( arg( 2, DState, Body ),
  678.     and( arg( 1, ProcState, ClauseAddr ),
  679.          nukeclause( ClauseAddr, Name, Arity ))
  680. )))))))))))))))).
  681.  
  682. nextClause( _ ).
  683. rule( nextClause( ProcState ),
  684.     and( getbp( Next ),
  685.     and( mangle( 1, ProcState, Next ),
  686.          fail
  687. ))).
  688.  
  689. rule( getbp( BP ),
  690.     and( $getbp,
  691.          getterm( BP )
  692. )).
  693.  
  694. %    keysort/2
  695.  
  696. rule(keysort(List,SortedList),
  697.         and(length(List,Length), keysort(Length,List,_,SortedList) )).
  698.         
  699. rule(keysort2(>,X1,X2,cons(X2,cons(X1,nil))), cut).
  700. keysort2(_,X1,X2,cons(X1,cons(X2,nil))).
  701.  
  702. rule(keysort(2,cons(X1,L1),L,R),
  703.         and(cut,
  704.         and(comprises(L1,X2,L),
  705.         and(compareKeys(Delta,X1,X2),keysort2(Delta,X1,X2,R))))).
  706.         
  707. rule(keysort(1,cons(X,L),L,cons(X,nil)), cut).
  708. rule(keysort(0,L,L,nil),cut).
  709.  
  710. rule(keysort(N,L1,L3,R),
  711.         and(is(N1,idiv(N,2)),
  712.         and(is(N2,sub(N,N1)),
  713.         and(keysort(N1,L1,L2,R1),
  714.         and(keysort(N2,L2,L3,R2), keymerge(R1,R2,R) ))))).
  715.         
  716. rule(keymerge(nil,R,R), cut).
  717. rule(keymerge(R,nil,R), cut).
  718. rule(keymerge(R1,R2,cons(X,R)),
  719.         and(comprises(R1,X1,R1a),
  720.         and(comprises(R2,X2,R2a),
  721.         and(compareKeys(Delta,X1,X2), keymerge(Delta,X,X1,X2,R1,R2,R1a,R2a,R) )))).
  722.  
  723. rule(keymerge(>,X,_,X,R1,_,_,R2a,R),
  724.         and(cut, keymerge(R1,R2a,R))).
  725.         
  726. rule(keymerge(_,X,X,_,_,R2,R1a,_,R), keymerge(R1a,R2,R)).
  727.  
  728. rule(compareKeys(Delta,pair(K1,X1),pair(K2,X2)),
  729.         compare(Delta,K1,K2)).
  730.         
  731.         
  732. %
  733. %%    setof( +Template, +Goal, -Solutions )
  734. %
  735. %    All the instances of Template when Goal is provable are
  736. %    collected into the list Solutions.  Variables occuring in
  737. %    Goal which do not also appear in Template and are not explicitly
  738. %    quantified, will cause setof/3 to generate multiple Solutions upon
  739. %    backtracking.  Duplicate solutions are removed.
  740. %
  741.  
  742.  
  743. rule(setof(Template,Goal,Set),
  744.         and(bagof(Template,Goal,RawSet), sort(RawSet,Set) )).
  745.         
  746.  
  747. %
  748. %%    bagof( +Template, +Goal, -Solutions )
  749. %
  750. %    All the instances of Template when Goal is provable are
  751. %    collected into the list Solutions.  Variables occuring in
  752. %    Goal which do not also appear in Template and are not explicitly
  753. %    quantified, will cause setof/3 to generate multiple Solutions upon
  754. %    backtracking.  Duplicate solutions are NOT removed.
  755. %
  756.  
  757. rule(bagof(Template,Goal,Bag),
  758.         and(excessVars(Goal,Template,NewGoal,ExcessVars),
  759.             $bagof2(ExcessVars,Template,NewGoal,Bag) )).
  760.             
  761. rule($bagof2(nil,Template,Goal,Bag),
  762.         and(cut,
  763.         and(findall(Template,Goal,Bag), different(Bag,nil) ))).
  764.         
  765. rule($bagof2(ExcessVars,Template,Goal,Bag),
  766.         and(findall(pair(ExcessVars,Template),Goal,RawBags),
  767.         and(keysort(RawBags,GroupedBags), pick(GroupedBags,ExcessVars,Bag) ))).
  768.         
  769. rule(pick(Bags,ExcessKey,OneBag),
  770.         and(different(Bags,nil),
  771.         and(select(Bags,Key1,Bag1,RestBags), decide(Key1,Bag1,RestBags,ExcessKey,OneBag) ))).
  772.         
  773. rule(decide(Key,Bag,nil,Key,Bag), cut).
  774. decide(Key,Bag,Bags,Key,Bag).
  775. rule(decide(A1,A2,Bags,Key,Bag), pick(Bags,Key,Bag)).
  776.  
  777. rule(excessVars(setof(NewTemplate,Goal,Set),Template,
  778.                 setof(NewTemplate,Goal,Set),Excess),
  779.         and(cut,excessVars(and(Goal,Set),and(NewTemplate,Template),_,Excess) )).
  780.         
  781. rule(excessVars(bagof(NewTemplate,Goal,Bag),Template,
  782.                 bagof(NewTemplate,Goal,Bag),Excess),
  783.         and(cut,excessVars(and(Goal,Bag),and(NewTemplate,Template),_,Excess) )).
  784.         
  785. rule(excessVars(@^(Var,Goal),Template,NewGoal,Excess),
  786.         and(cut, excessVars(Goal,cons(Var,Template),NewGoal,Excess))).
  787.         
  788. rule(excessVars(Goal,Template,Goal,Excess),
  789.         and(getVars(Goal,nil,Vars),
  790.         and(getVars(Template,nil,TemplateVars), filter(Vars,TemplateVars,nil,Excess)))).
  791.         
  792. rule(select(cons(pair(Key,OutVars),RestBags),Key,
  793.             cons(OutVars,RestOutVars),LeftOverBags),
  794.         and(cut, select(RestBags,Key,RestOutVars,LeftOverBags) )).
  795.         
  796. select(LeftOverBags,Key,nil,LeftOverBags).
  797.  
  798.  
  799. rule(getVars(Var,Vars,Vars),
  800.         and(var(Var), alreadyIn(Term,Vars) )).
  801.         
  802. rule(getVars(Var,Vars,cons(Var,Vars)),
  803.         and(var(Var), cut)).
  804.         
  805. rule(getVars(Atom,Vars,Vars),
  806.         and(atomic(Atom), cut)).
  807.         
  808. rule(getVars(Compound,VarsIn,VarsOut),
  809.         and(univ(Compound,cons(_,Arguments)), getVars2(Arguments,VarsIn,VarsOut))).
  810.         
  811.  
  812. getVars2(nil,Vars,Vars).
  813. rule(getVars2(cons(Arg,Args),VarsIn,VarsOut),
  814.         and(getVars(Arg,VarsIn,Vars1), getVars2(Args,Vars1,VarsOut) )).
  815.         
  816. filter(nil,_,Filtered,Filtered).
  817.  
  818. rule(filter(cons(Var,Vars),Filter,Inter,Filtered),
  819.         and(alreadyIn(Var,Filter),
  820.         and(cut, filter(Vars,Filter,Inter,Filtered) ))).
  821.         
  822. rule(filter(cons(Var,Vars),Filter,Inter,Filtered),
  823.         filter(Vars,Filter,cons(Var,Inter),Filtered) ).
  824.         
  825. rule(alreadyIn(Term,cons(Term1,_)), ==(Term,Term1) ).
  826. rule(alreadyIn(Term,cons(_,Terms)), alreadyIn(Term,Terms) ).
  827.  
  828.  
  829. %    buffer manipulation
  830.  
  831. %
  832. %%    newbuffer( -Buffer, +Size )
  833. %
  834.  
  835. rule(newbuffer(Buffer,Size),
  836.         and($newbuffer(Size), getterm(Buffer) )).
  837.  
  838. %
  839. %%    buffersize( +Buffer, -Size )
  840. %
  841.  
  842. rule(buffersize(Buffer,Size),
  843.         and($buffersize(Buffer), getterm(Size) )).
  844.  
  845. %
  846. %%    bufferpeek( +Buffer, +Offset, -Element )
  847. %
  848.  
  849. rule(bufferpeek(Buffer,Offset,Element),
  850.         and($bufferpeek(Buffer,Offset), getterm(Element) )).
  851.  
  852. %
  853. %%    bufferpoke( +Buffer, +Offset, +Element )
  854. %
  855.  
  856. %
  857. %%    statistics( -StatisticsVector )
  858. %
  859. %    StatisticsVector is unified with a term of the following form:
  860. %
  861. %    $stat( S, H, T, Ticks, C, P, L )
  862. %
  863. %    where:    S = size of local stack (bytes)
  864. %            H = size of heap (bytes)
  865. %            T = size of trail (bytes)
  866. %            Ticks = Mac OS Ticks
  867. %            C = clause space used (bytes)
  868. %            P = size of procedure table
  869. %            L = current logical inference count
  870. %
  871.  
  872. rule( statistics( S ),
  873.     and( $statistics,
  874.          getterm( S )
  875. )).
  876.  
  877.  
  878. %
  879. %    main/0 -- used to initiate the user interface
  880. %
  881.  
  882. rule(main,
  883.     and(getterm(Goal),
  884.     and(call(Goal),
  885.     and(success,
  886.     cut
  887. )))).
  888. rule(main,failurehole).
  889.  
  890. rule(failurehole,
  891.     and( failure,
  892.          failurehole
  893. )).
  894. rule(failurehole,
  895.     failurehole
  896. ).
  897.  
  898. rule( interactive,
  899.     and( writel( 'Type halt. to get out' ),
  900.          interactive2
  901. )).
  902.  
  903. rule( interactive2,
  904.     and( doQuery,
  905.          fail
  906. )).
  907. rule( interactive2, interactive2 ).
  908.  
  909. rule( doQuery,
  910.     and( writel( 'Goal?' ),
  911.     and( read( Q ),
  912.     and( call( Q ),
  913.     and( nl,
  914.     and( writel( Q ),
  915.     and( writel( 'More Answers?' ),
  916.     and( read( YesNo ),
  917.     and( moreAnswers( YesNo ),
  918.          cut
  919. ))))))))).
  920. rule( doQuery,
  921.     writel( 'No' )
  922. ).
  923.  
  924. rule( moreAnswers( y ),
  925.     and( cut,
  926.          fail
  927. )).
  928. rule( moreAnswers( yes ),
  929.     and( cut,
  930.          fail
  931. )).
  932. moreAnswers( AnythingElse ).
  933.  
  934. rule( consult,
  935.     and( read( Clause ),
  936.          addClause( Clause )
  937. )).
  938. rule( consult, consult ).
  939.  
  940. addClause( end ).
  941. addClause( end_of_file ).
  942. rule( addClause( Clause ),
  943.     and( assertz( Clause ),
  944.          fail
  945. )).
  946.  
  947. rule( ufault,
  948.     and( =( X, f( a, Y, b )),
  949.     and( =( Y, f( a, X, b )),
  950.          =( X, Y )
  951. ))).
  952.  
  953. rule( batch( Goal ),
  954.     and( call( Goal ),
  955.     and( nl,
  956.     and( writel( 'Yes' ),
  957.          halt
  958. )))).
  959. rule( batch( Goal ),
  960.     and( nl,
  961.     and( writel( 'No' ),
  962.          halt
  963. ))).
  964.